perm filename RUNFN1.LSP[MLI,LSP] blob sn#165008 filedate 1975-06-24 generic text, type T, neo UTF8

(DEFPROP &X&
 T
SPECIAL)

(DEFPROP &Y&
 T
SPECIAL)

(DEFPROP &FOR
 (LAMBDA (X) (&FOR1 (CADADR X) (CAR (CDADDR X)) (CADR (CADDDR X)) (CADAR (CDDDDR X)) (&LISTLST (CADADR X) 1)))
MACRO)

(DEFPROP &DO
 (LAMBDA (X) (&LOOP1 (CAR X) (CADADR X) (CAR (CDADDR X)) (CADR (CADDDR X))))
MACRO)

(DEFPROP &WHILE
 (LAMBDA (X) (&LOOP1 (CAR X) (CADADR X) (CADR (CADDDR X)) (CAR (CDADDR X))))
MACRO)

(DEFPROP &INDEX
 (LAMBDA (X) (&CARS (CADR X) (CDADDR X) 4))
MACRO)

(DEFPROP &FOR
 (LAMBDA (L FN EX B)
  (PROG (&Y& NOTFIRST LST)
        (SETQ LST
              (MAPCAR (FUNCTION
                       (LAMBDA (&X&)
                        (CONS (LIST (CADR &X&)
                                    (EQ (CADDR &X&) (QUOTE ON))
                                    (EQ (CADDR &X&) (QUOTE ←))
                                    (EQ (CAR &X&) (QUOTE NEW))
                                    (COND ((GET (CADR &X&) (QUOTE VALUE)) (CDR (GET (CADR &X&) (QUOTE VALUE))))
                                          (T (CDR (GET (QUOTE &UNBOUND&) (QUOTE VALUE))))))
                              (EVAL (CADDDR &X&)))))
                      L))
   LOOP (COND ((&FORSTOP LST) (&FORRESET LST T) (RETURN &Y&)))
        (MAPCAR (FUNCTION (LAMBDA (&X&) (SET (CAAR &X&) (COND ((CADAR &X&) (CDR &X&)) (T (CADR &X&)))))) LST)
        (SETQ &Y& (EVAL (COND (NOTFIRST (LIST FN (QUOTE &Y&) EX)) (T (SETQ NOTFIRST T) EX))))
        (COND ((EVAL B) (&FORRESET LST NIL) (RETURN &Y&)))
        (SETQ LST
              (MAPCAR (FUNCTION
                       (LAMBDA (&X&) (CONS (CAR &X&) (COND ((CADDAR &X&) (EVAL (CDDR &X&))) (T (CDDR &X&))))))
                      LST))
        (GO LOOP)))
EXPR)

(DEFPROP &FORSTOP
 (LAMBDA (L) (AND L (OR (NULL (CDAR L)) (&FORSTOP (CDR L)))))
EXPR)

(DEFPROP &FORRESET
 (LAMBDA (L &Y&)
  (MAPCAR (FUNCTION
           (LAMBDA (&X&)
            (COND ((CADDDR (CAR &X&)) (SET (CAAR &X&) (CADDDR (CDAR &X&))))
                  (T (AND &Y& (NULL (CDR &X&)) (SET (CAAR &X&) NIL))))))
          L))
EXPR)

(DEFPROP &RANGE
 (LAMBDA (LOW UP INC) (COND ((EQUAL INC 0) NIL) (T (&RANGE1 LOW UP INC (*GREAT INC 0) (*LESS INC 0)))))
EXPR)

(DEFPROP &RANGE1
 (LAMBDA (LOW UP INC POS NEG)
  (COND ((OR (AND POS (*GREAT LOW UP)) (AND NEG (*LESS LOW UP))) NIL)
        (T (LIST LOW (QUOTE &RANGE1) (*PLUS LOW INC) UP INC POS NEG))))
EXPR)

(DEFPROP &DO
 (LAMBDA (FN EX B) (PROG (V) L (SETQ V (FN V (EVAL EX))) (COND ((EVAL B) (RETURN V)) (T (GO L)))))
EXPR)

(DEFPROP &WHILE
 (LAMBDA (FN B EX) (PROG (V) L (COND ((EVAL B) (SETQ V (FN V (EVAL EX)))) (T (RETURN V))) (GO L)))
EXPR)

(DEFPROP &INDEX
 (LAMBDA (L X) (COND (X (CAR (SUFLIST (CAR (SUFLIST L (SUB1 (CAR X)))) (SUB1 X)))) (T L)))
EXPR)